perm filename T1.F4[M11,LCS] blob
sn#519432 filedate 1980-06-24 generic text, type T, neo UTF8
00100 C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
00200 SUBROUTINE TRANS(JJJ)
00300 COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
00400 DIMENSION NN(100)
00500 C W(35) FOR PARAMETERS
00600 C THE 'ROUT' COMMON BLOCK IS 1ST OUTPUT BLOCK IN 'PASS3'.
00700 COMMON /ROUT/I(200) ,RX(80),JX(80) /TR/LX(12),K
00800 1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
00900 1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
01000 1,ENDX,J /KNAM/IPLAY,JFLNM /IFIRST/IFIRST,IDT
01100 1 /INST/INST(27)
01200 1 /WDZ/WDZ(14),JWD(12)
01300 COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
01400 COMMON LL /P/W(1) /CONV/ICONV /FQDR/FQDR(28,27),INSN
01500 INTEGER FQDR
01600 C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
01700 INTEGER*4 IDBL,JANP,JBLA,JFLNM,JDBG,
01800 1 INST,INAM,JSEMI,ICOLON
01900 EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
02000 1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
02100 1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST),(IEQUAL,LX(8))
02200 1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
02300
02400 DATA LX/' ',';', '*','/','-','+','←','=','<' ,',' ,'(', ')'/,
02500 1 IDOT/'.'/, IDEV/1/,JPRNT/1/,JFLNM/'TRNS'/,N0/'0'/,N9/'9'/
02600 1,JBLA/' '/,JDBG/'# '/,JPERC/'% '/,JSEMI/'; '/
02700 C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
02800 DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./,JQUOT/'" '/
02900 1,JEXP/'! '/,JANP/'& '/,ICONV/-1/,JCOLON/': '/
03000 C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
03100
03200 GO TO (555,500) JJJ
03300 555 IF(IFIRST)404, 5,5
03400 404 IGEN=-1
03500 KA=1
03600 C KA IS POINTER TO INPUT ARRAY
03700 IF(INUM.NE.0)GO TO 30
03800 DO 411 K=1,27
03900 411 INST(K)=0
04000 CIN DO 411 K=1,108
04100 CIN411 IINS(K)=0
04200 C ZERO OUT INSTR. NAME ARRAY.
04300 30 IPLAY=0
04400 ENDX=0
04500 KK=0
04600 JSEM=0
04700 INS=-1
04800 402 IDEV=1
04900 412 WRITE(JTYPE,1)
05000 1 FORMAT(' INPUT? '$)
05100 100 FORMAT(' >'$)
05200 2 FORMAT(A4)
05300 READ(JTYPE,2)IDBL
05400 C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
05500 IF(IDBL.NE.JBLA)GO TO 400
05600 IDEV=5
05700 GO TO 5
05800 400 IF(IDBL.NE.JANP)GO TO 602
05900 JPRNT=-JPRNT
06000 GO TO 412
06100 C!*** & IS PRNT-NOPRNT FLIPFLOP
06200 602 IF(IDBL.NE.JQUOT)GO TO 408
06300 C!*** " FOR INSTRUMENT LIST.
06400 DO 606 K=1,INUM
06500 JK=INSNUM(K)
06600 MM=NPAR(JK)-2
06700 606 WRITE(JTYPE,607)INST(K),JK,MM
06800 GO TO 402
06900 607 FORMAT(1X,A4,' INS#',I2,' PARAMS=',I2)
07000 C!*** PRINTS INST INFO.
07100 408 IF(IDBL.NE.JEXP)GO TO 603
07200 C TRIGGERS ICONV FLIPFLOP
07300 IF(ICONV.LT.0)GO TO 2408
07400 ICONV=-1
07500 WRITE(JTYPE, 3408)
07600 GO TO 412
07700 2408 ICONV=0
07800 WRITE(JTYPE, 4408)
07900 GO TO 412
08000 3408 FORMAT(' OUTPUT=TEST.SND'/)
08100 4408 FORMAT(' OUTPUT=TEST.DAT'/)
08200 603 IF(IDBL.EQ.JPERC)CALL PLAY
08300 C TYPE % TO RE-PLAY SOUND
08400 2326 FORMAT(1X100A1)
08500 410 IF(IDBL.EQ.JCOLON)CALL EXIT
08600 C TYPE ':' TO EXIT AND CLOSE ALL FILES.
08700 C11******************************************???????????????????
08800 CALL CLOSIT(IDEV)
08900 CCCC CALL CLOSE(IDEV)
09000 C11******************************************???????????????????
09100 CALL DISKO(IDEV,IDBL,3)
09200 C 3=OPEN FORMATTED INPUT FILE.
09300 4 FORMAT(100A1)
09400
09500 5 IF(KA.NE.1)GO TO 521
09600 502 IF(IDEV.NE.5)GO TO 601
09700 C*******************************
09800 IF(IGEN.NE.2)IGEN=-1
09900 503 WRITE(JTYPE, 100)
10000 C*******************************
10100 601 KA=1
10200 READ(IDEV,4,END=404)NN
10300 121 DO 421 LEND=100,1,-1
10400 C FIND LAST CHAR. IN LINE
10500 421 IF(NN(LEND).NE.IBLA)GO TO 621
10600 C NOW WE'VE FOUND A BLANK LINE
10700 IF(IDEV.EQ.1)GO TO 601
10800 GO TO 402
10900 621 IF(IDEV.EQ.5)GO TO 521
11000 IF(JPRNT.LT.0)WRITE(JTYPE, 2326)(NN(IJI),IJI=1,LEND)
11100 521 IF(KK.EQ.0)JA=0
11200 C KK IS FLAG FOR CONTINUATION LINES.
11300 DO 21 LSEM=KA,LEND
11400 LS=NN(LSEM)
11500 IF(LS.NE.LESS)GO TO 21
11600 KK=0
11700 GO TO 601
11800 21 IF(LS.EQ.ISEMI)GO TO 821
11900 C SET FLAG TO LOOP BACK TO READ ANOTHER LINE
12000 KK=-1
12100 GO TO 721
12200
12300 821 KK=0
12400 C SET KK TO 0 EVERY TIME WE HIT A SEMICOLON
12500 221 IF(LSEM.EQ.1)GO TO 721
12600 KB=LSEM-1
12700 IF(NN(KB).NE.IBLA)GO TO 721
12800 C DELETE BLANKS BEFORE A SEMICOLON
12900 NN(KB)=ISEMI
13000 NN(LSEM)=IBLA
13100 IF(LEND.EQ.LSEM)LEND=LEND-1
13200 LSEM=LSEM-1
13300 GO TO 221
13400 721 IF(JA.EQ.0)GO TO 921
13500 JA=JA+1
13600 I(JA)=IBLA
13700 C INSERT A BLANK IF A CONTINUATION LINE.
13800 921 KC=IBLA
13900 C LEADING BLANKS AND MULTIPLE BLANKS ARE DELETED.
14000 DO 321 KB=KA,LSEM
14100 C LSEM IS CHAR COUNT IN I ARRAY NOW (LOCATES THE SEMI COLON)
14200 K=NN(KB)
14300 IF(K.NE.IBLA)GO TO 1021
14400 IF(KC.EQ.IBLA)GO TO 321
14500 C DELETE STRINGS OF BLANKS
14600 1021 JA=JA+1
14700 I(JA)=K
14800 KC=K
14900 321 CONTINUE
15000 C CURRENTLY CAN STORE 200 CHARS. IN I ARRAY. (ENOUGH FOR 30 PARAMS?)
15100 KA=LSEM+1
15200 IF(KA.GT.LEND)KA=1
15300 IF(KK.NE.0)GO TO 502
15400 C GO READ MORE IF NO SEMICOLON WAS FOUND.
15500 IF(I(1).EQ.ISEMI)GO TO 5
15600 C CATCHES DUPLICATE SEMICOLON
15700 1408 DO 407 K=1,80
15800 407 JX(K)=IBLA
15900 406 MM=0
16000 C INIT VARIOUS THINGS
16100 DO 4061 J=2,80,2
16200 4061 RX(J)=0
16300 J=-1
16400 IPRNT=0
16500 119 JI=0
16600 9 M=0
16700 N=JI+1
16800 6 JI=JI+1
16900 KCHAR=I(JI)
17000 DO 7 L=1,12
17100 7 IF(KCHAR.EQ.LX(L))GO TO 8
17200 C JUMP OUT IF PUNCT., SPACE, SEMI., ETC.
17300 M=M+1
17400 GO TO 6
17500 C!**** NO STRING CAN EXCEED 10 CHARS.
17600 8 IF(M.EQ.0)GO TO 140
17700 IF(M.GT.10)M=10
17800 MM=MM+1
17900 IF(MM.LE.40)GO TO 88
18000 WRITE(JTYPE, 888)(I(JJ),JJ=N,N+9)
18100 STOP
18200 888 FORMAT(' LINE TOO LONG -- ',10A1)
18300 88 JJ=I(N)
18400 IF(JJ.GT.N9)GO TO 16
18500 IF(JJ.NE.IDOT.AND.JJ.LT.N0)GO TO 16
18600 C**** 8240='0' 8249='9'
18700 C!***** JUMP IF 1ST CHAR. IS A LETTER.
18800 Y=0
18900 DOT=10.
19000 DO 18 JK=N,N+M-1
19100 KB=I(JK)
19200 IF(KB.NE.IDOT)GO TO 17
19300 DOT=.1
19400 GO TO 18
19500 17 X=NASCI(KB)
19600 C!**** CHANGE ASCII INTO NUMBER
19700 IF(DOT.LT.1)GO TO 19
19800 Y=Y*DOT+X
19900 GO TO 18
20000 19 Y=Y+X*DOT
20100 DOT=DOT/10.
20200 18 CONTINUE
20300 IF(IGEN.EQ.2)Y=Y*100+1000.
20400 C ABOVE PUTS CONSTANTS IN INS DEFINITIONS. PLUS ONLY. LIMIT??
20500 RX(MM*2-1)=Y
20600 RX(MM*2)=-9999.0
20700 GO TO 140
20800
20900 16 JK=MM*2-1
21000 CALL MPACK(M,I(N),JX(JK),N)
21100 C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
21200 IJ=JX(JK)
21300 IF(IJ.GE.0)GO TO 144
21400 C IF IJ < 0, THEN IT'S A LETTER
21500 JX(MM*2)=M
21600 C SAVE THE WD CNT OF POTENTIAL INST. NAME.
21700 GO TO 143
21800 144 IF(IJ.NE.408)GO TO 140
21900 C "WORD" TYPES OUT RESERVED WORD LIST
22000 WRITE(JTYPE, 244)WDZ,JWD
22100 WRITE(JTYPE, 245)
22200 GO TO 503
22300 244 FORMAT(15(1XA4))
22400 245 FORMAT(' %=REPLAY, &=SHOW INPUT, !=SOUND-SIGHT, "=
22500 1INSTS., :=EXIT, CLOSE FILES')
22600 140 IF(IJ.EQ.400)GO TO 5
22700 C 400='PLAY;' THIS CAN BE THROWN AWAY NOW.
22800 143 IF(KCHAR.EQ.IBLA)GO TO 10
22900 IF(L.EQ.7)KCHAR=IEQUAL
23000 141 MM=MM+1
23100 KI=MM*2-1
23200 JX(KI)=KCHAR
23300 10 IF(JI.EQ.JA)GO TO 15
23400 C JA POINTS TO LAST CHAR. TO LOOK AT FOR NOW.
23500 1010 IF(I(JI+1).NE.IBLA)GO TO 11
23600 JI=JI+1
23700 GO TO 1010
23800 11 IF(JI.LT.JA)GO TO 9
23900 C NOW WE HAVE ALL ITEMS IN IX ARRAY
24000 IF(MM.GT.1)GO TO 15
24100 C CATCH 'WORD ;' AT END OF LINE
24200 IF(M.EQ.0)GO TO 5
24300 15 MM=MM*2
24400 142 J=-1
24500 IF(INS.LT.0)GO TO 305
24600 IF(INS.EQ.2)GO TO 305
24700 MM=0
24800 INS=-1
24900 C!***** NOW INITIALIZATION COMPLETE
25000 GO TO 5
25100 50 LL=LL-1
25200 IF(IGEN)308,309,309
25300 309 IF(IJ.EQ.12)IGEN=-1
25400 C!*** FOUND 'END'
25500 IF(IJ.NE.412)GO TO 59
25600 C JUMP IF NOT 'INS' LINE.
25700 IF(LL.NE.2)GO TO 59
25800 C IF WDCNT IS 2, DO THE NEXT
25900 LL=3
26000 C NOW YOU CAN HAVE 'INS 2;' INSTEAD OF 'INS 0 2;' ETC. (EITHER WAY!)
26100 W3=W2
26200 W2=0
26300 GO TO 59
26400 308 W1=1
26500 IK=W2
26600 IF(LL.GT.NPAR(IK))GO TO 56
26700 54 IF(LL.LT.3)LL=3
26800 DO 55 K=LL,NPAR(IK)
26900 55 W(K)=P(K-2)
27000 C!***** GET INFO ALREADY IN PARAMS
27100 56 DO 57 K=3,LL
27200 57 P(K-2)=W(K)
27300 C!**** FILL UP P LIST AGAIN
27400 X=W3
27500 C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
27600 W3=W2
27700 W2=X
27800 58 LL=NPAR(IK)
27850 CC TYPE *,LL,IK
27900 DO 52 K=5,LL
28000 KI=FQDR(K-4,IK)
28100 IF(KI)53,52,2352
28200 2352 W(K)=RMAG/W(K)
28300 GO TO 52
28400 53 W(K)=RMAG*W(K)
28500 52 CONTINUE
28600 IF(ENDX.LT.W2+P2)ENDX=W2+P2
28700 59 IF(W1.NE.2.)GO TO 592
28800 IF(LL.EQ.2)GO TO 597
28900 C JUMP IF 'END' OF INS DEF.
29000 IF(LL.NE.3)GO TO 595
29100 C JUMP IF NOT AN INST DEF.
29200 PSV=0
29300 SV=35
29400 C EXPLAIN USE OF STORAGE PARAMS!!
29500 INSN=W3
29600 C INS DEF NUM.
29650 CC TYPE *,INSN
29700 DO 586 K=1,28
29800 C CLEAR FREQ-DUR FLAGS FOR THIS INST.
29900 586 FQDR(K,INSN)=0
30000 C LIST OF INST NAMES MUST FOLLOW 'INS N;' !!!ALWAYS!!!
30100 596 READ(IDEV,2,END=587)INAM
30200 IF(INAM.EQ.JSEMI)GO TO 592
30300 C LIST OF INST NAMES TERMINATES WITH ';'.
30400 DO 588 K=1,INUM
30500 IF(INAM.NE.INST(K))GO TO 588
30600 INST(K)=INAM
30700 INSNUM(K)=INSN
30800 GO TO 589
30900 587 PAUSE 'MISSING SEMICOLON'
31000 588 CONTINUE
31100 INUM=INUM+1
31200 INST(INUM)=INAM
31300 C LIST OF INST NAMES TERMINATES WITH ';'.
31400 INSNUM(INUM)=INSN
31500 589 IF(JPRNT.LT.0)WRITE(JTYPE, 244)INAM
31600 GO TO 596
31700
31800 595 DO 593 K=3,LL
31900 X=W(K)
32000 IF(X.LT.0.OR.X.GT.100)GO TO 593
32100 IF(X.GT.PSV)PSV=X
32200 C CHECK FOR OVERLAPPING PARAM NUMS.
32300 593 CONTINUE
32400 IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
32500 1 .AND.W3.NE.115)GO TO 592
32600 C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
32700 C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
32800 X=W3
32900 594 LL=LL+1
33000 W(LL)=SV
33100 SV=SV-1
33200 C DECREMENT THE HIGH PARAM NUM.
33300 IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
33400 CIN IF(SV.LT.PSV)CALL ERROR(5)
33500 C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
33600 IF(X.NE.111.AND.X.NE.104)GO TO 592
33700 IF(X.EQ.111)X=0
33800 IF(X.EQ.104)X=111
33900 GO TO 594
34000
34100 597 NPAR(INSN)=PSV
34200 C SAVE THE HIGHEST PARAM NUM.
34300
34400 592 IF(JPRNT.GE.0)GO TO 591
34500 WRITE(JTYPE, 51)LL,(W(K),K=1,LL)
34600 C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
34700 591 IDT=2
34800 RETURN
34900
35000 500 IFIRST=0
35100 IF(IGEN.EQ.0)IGEN=-1
35200 IF(W1.NE.6)GO TO 555
35300 RETURN
35400 C W1=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
35500
35600 306 IF(JPRNT.LT.0)WRITE(JTYPE, 1307)(W(K),K=1,LL-1)
35700 IF(JPRNT.GT.0)WRITE(JTYPE, 307)(W(K),K=1,LL-1)
35800 IPRNT=0
35900 C!** RESET NO-PRNT FLAG
36000 INS=-1
36100 GO TO 5
36200 C!** GO READ ANOTHER LINE
36300 305 CALL MSCAN
36400 IF(IJ.EQ.401)GO TO 500
36500 C 401=FINISH WAS FOUND.
36600 IF(IPRNT.LT.0)GO TO 306
36700 IF(JSEM.EQ.0)GO TO 5
36800 GO TO 50
36900 51 FORMAT(I3,35F10.3/)
37000 307 FORMAT('+',F8.2,$)
37100 1307 FORMAT(F10.3)
37200 END
37300
37400 FUNCTION NASCI(N)
37500 CPDP10 DATA IEX/536870912/,IZERO/'0'/
37600 C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
37700 CPDP10 NASCI=(N-IZERO)/IEX
37800 C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
37900 NASCI=N-8240
38000 C THIS FORM FOR PDP11
38100 END
38200